home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / generate.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  37.2 KB  |  795 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/generate.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (LOCALLY (DECLARE (SPECIAL @LAMBDA-ENCOUNTERED?))
  9.          (SETQ @LAMBDA-ENCOUNTERED? (MAKE-FLUID SCHI:FALSE)))
  10. (SCHI:SET-FUNCTION-FROM-VALUE '@LAMBDA-ENCOUNTERED?
  11.                               'SCHEME::@LAMBDA-ENCOUNTERED?)
  12. (DEFUN GENERATE-TOP
  13.        (NODE ENV IGNORE?)
  14.        (CASE (NODE-TYPE NODE)
  15.              ((SCHEME::BEGIN)
  16.                (PROGNIFY
  17.                  (APPEND
  18.                    (DEPROGNIFY
  19.                      (GENERATE-TOP (BEGIN-FIRST NODE)
  20.                                    ENV
  21.                                    SCHI:TRUE))
  22.                    (DEPROGNIFY
  23.                      (GENERATE-TOP (BEGIN-SECOND NODE)
  24.                                    ENV
  25.                                    IGNORE?)))))
  26.              ((SCHEME::DEFINE) (GENERATE-DEFINE NODE ENV))
  27.              (OTHERWISE (GENERATE-EXPRESSION-TOP NODE ENV IGNORE?))))
  28. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-TOP
  29.                               'SCHEME::GENERATE-TOP)
  30. (DEFUN GENERATE-DEFINE
  31.        (DEF ENV)
  32.        (DECLARE (SPECIAL @WHERE))
  33.        (LET ((LHS (DEFINE-LHS DEF)))
  34.          (LET-FLUID @WHERE
  35.                     (PROGRAM-VARIABLE-NAME LHS)
  36.                     #'(LAMBDA NIL
  37.                        (LET
  38.                         ((RHS (DEFINE-RHS DEF))
  39.                          (CL-SYM (PROGRAM-VARIABLE-CL-SYMBOL LHS))
  40.                          (NAME (PROGRAM-VARIABLE-NAME LHS)))
  41.                         (IF (SCHI:TRUEP (MUTABLE-PROGRAM-VARIABLE? LHS))
  42.                          (CONS 'PROGN
  43.                           (CONS (GENERATE-SETQ-TOP LHS RHS ENV)
  44.                            (LIST
  45.                             (CONS 'SCHI:SET-FORWARDING-FUNCTION
  46.                              (CONS (CONS 'QUOTE (LIST CL-SYM))
  47.                               (LIST (CONS 'QUOTE (LIST NAME))))))))
  48.                          (IF (SCHI:TRUEP (LAMBDA? RHS))
  49.                           (CONS 'PROGN
  50.                            (CONS
  51.                             (CONS 'DEFUN
  52.                              (CONS CL-SYM (CDR (GENERATE-LAMBDA-TOP RHS ENV))))
  53.                             (LIST
  54.                              (CONS 'SCHI:SET-VALUE-FROM-FUNCTION
  55.                               (CONS (CONS 'QUOTE (LIST CL-SYM))
  56.                                (LIST (CONS 'QUOTE (LIST NAME))))))))
  57.                           (CONS 'PROGN
  58.                            (CONS (GENERATE-SETQ-TOP LHS RHS ENV)
  59.                             (LIST
  60.                              (CONS 'SCHI:SET-FUNCTION-FROM-VALUE
  61.                               (CONS (CONS 'QUOTE (LIST CL-SYM))
  62.                                (LIST (CONS 'QUOTE (LIST NAME)))))))))))))))
  63. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-DEFINE
  64.                               'SCHEME::GENERATE-DEFINE)
  65. (DEFUN GENERATE-EXPRESSION-TOP
  66.        (NODE ENV IGNORE?)
  67.        (DECLARE (SPECIAL CONT/VALUE
  68.                          CONT/IGNORE
  69.                          @LAMBDA-ENCOUNTERED?))
  70.        (LET-FLUID @LAMBDA-ENCOUNTERED?
  71.                   SCHI:FALSE
  72.                   #'(LAMBDA NIL
  73.                      (NOTING-VARIABLE-REFERENCES
  74.                       #'(LAMBDA NIL
  75.                          (LET
  76.                           ((CODE
  77.                             (GENERATE NODE ENV
  78.                              (IF (SCHI:TRUEP IGNORE?) CONT/IGNORE CONT/VALUE))))
  79.                           (EMIT-TOP-LEVEL
  80.                            (LOCALLY-SPECIALIZE (DEPROGNIFY CODE)))))))))
  81. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-EXPRESSION-TOP
  82.                               'SCHEME::GENERATE-EXPRESSION-TOP)
  83. (DEFUN GENERATE-LAMBDA-TOP
  84.        (NODE ENV)
  85.        (DECLARE (SPECIAL CONT/VALUE
  86.                          @LAMBDA-ENCOUNTERED?))
  87.        (LET-FLUID @LAMBDA-ENCOUNTERED?
  88.                   SCHI:FALSE
  89.                   #'(LAMBDA NIL
  90.                      (NOTING-VARIABLE-REFERENCES
  91.                       #'(LAMBDA NIL
  92.                          (LET
  93.                           ((BVL+BODY
  94.                             (GENERATE-LAMBDA-AUX NODE ENV CONT/VALUE)))
  95.                           (LET ((BODY (LOCALLY-SPECIALIZE (CDR BVL+BODY))))
  96.                            (CONS 'LAMBDA
  97.                             (CONS (CAR BVL+BODY)
  98.                              (IF
  99.                               (AND (CONSP BODY) (NULL (CDR BODY))
  100.                                (SCHI:TRUEP (CAR-IS? (CAR BODY) 'LOCALLY)))
  101.                               (CDR (CAR BODY)) BODY))))))))))
  102. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LAMBDA-TOP
  103.                               'SCHEME::GENERATE-LAMBDA-TOP)
  104. (DEFUN GENERATE-SETQ-TOP
  105.        (LHS RHS ENV)
  106.        (DECLARE (SPECIAL CONT/IGNORE
  107.                          @LAMBDA-ENCOUNTERED?))
  108.        (LET-FLUID @LAMBDA-ENCOUNTERED?
  109.                   SCHI:FALSE
  110.                   #'(LAMBDA NIL
  111.                      (NOTING-VARIABLE-REFERENCES
  112.                       #'(LAMBDA NIL
  113.                          (LET ((CODE (GENERATE RHS ENV CONT/IGNORE)))
  114.                           (NOTE-VARIABLE-REFERENCE! LHS)
  115.                           (EMIT-TOP-LEVEL
  116.                            (LOCALLY-SPECIALIZE
  117.                             (LIST
  118.                              (CONS 'SETQ
  119.                               (CONS (PROGRAM-VARIABLE-CL-SYMBOL LHS)
  120.                                (LIST CODE))))))))))))
  121. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-SETQ-TOP
  122.                               'SCHEME::GENERATE-SETQ-TOP)
  123. (DEFUN GENERATE
  124.        (NODE ENV CONT)
  125.        (CASE (NODE-TYPE NODE)
  126.              ((SCHEME::LOCAL-VARIABLE)
  127.                (GENERATE-LOCAL-VARIABLE NODE ENV CONT))
  128.              ((SCHEME::PROGRAM-VARIABLE)
  129.                (GENERATE-PROGRAM-VARIABLE NODE ENV CONT))
  130.              ((SCHEME::CONSTANT) (GENERATE-CONSTANT NODE ENV CONT))
  131.              ((SCHEME::CALL) (GENERATE-CALL NODE ENV CONT))
  132.              ((SCHEME::LAMBDA) (GENERATE-LAMBDA NODE ENV CONT))
  133.              ((SCHEME::LETREC) (GENERATE-LETREC NODE ENV CONT))
  134.              ((SCHEME::IF) (GENERATE-IF NODE ENV CONT))
  135.              ((SCHEME::BEGIN) (GENERATE-BEGIN NODE ENV CONT))
  136.              ((SCHEME::SET!) (GENERATE-SET! NODE ENV CONT))
  137.              (OTHERWISE (NOTE "don't know how to generate"
  138.                               NODE))))
  139. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE
  140.                               'SCHEME::GENERATE)
  141. (DEFUN GENERATE-LIST
  142.        (NODE-LIST ENV)
  143.        (DECLARE (SPECIAL CONT/VALUE))
  144.        (MAPCAR #'(LAMBDA (NODE)
  145.                          (GENERATE NODE ENV CONT/VALUE))
  146.                NODE-LIST))
  147. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LIST
  148.                               'SCHEME::GENERATE-LIST)
  149. (DEFUN GENERATE-BODY
  150.        (NODE ENV CONT)
  151.        (DEPROGNIFY (GENERATE NODE ENV CONT)))
  152. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-BODY
  153.                               'SCHEME::GENERATE-BODY)
  154. (DEFUN GENERATE-CONSTANT
  155.        (NODE ENV CONT)
  156.        ENV
  157.        (LET ((VAL (CONSTANT-VALUE NODE)))
  158.          (IF (SCHI:TRUEP (CONSTANT-QUOTED? NODE))
  159.              (DELIVER-VALUE-TO-CONT (CONS 'QUOTE (LIST VAL))
  160.                                     CONT)
  161.              (IF (EQ VAL SCHI:TRUE)
  162.                  (DELIVER-VALUE-TO-CONT 'SCHI:TRUE CONT)
  163.                  (IF (EQ VAL SCHI:FALSE)
  164.                      (IF (EQ (CONTINUATION-TYPE CONT)
  165.                              'SCHEME::CONT/TEST)
  166.                          'NIL
  167.                          (DELIVER-VALUE-TO-CONT 'SCHI:FALSE CONT))
  168.                      (DELIVER-VALUE-TO-CONT VAL CONT))))))
  169. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-CONSTANT
  170.                               'SCHEME::GENERATE-CONSTANT)
  171. (DEFUN GENERATE-LOCAL-VARIABLE
  172.        (VAR ENV CONT)
  173.        ENV
  174.        (LET ((SUB (VARIABLE-SUBSTITUTION VAR)))
  175.          (DELIVER-VALUE-TO-CONT
  176.            (IF (CONSP SUB)
  177.                (CASE (CAR SUB)
  178.                      ((SCHEME::VAL) (CADR SUB))
  179.                      ((SCHEME::FUN) (CONS 'FUNCTION
  180.                                           (LIST (CADR SUB))))
  181.                      (OTHERWISE
  182.                        (.ERROR "lossage in generate-local-variable"
  183.                                SUB)))
  184.                SUB)
  185.            CONT)))
  186. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LOCAL-VARIABLE
  187.                               'SCHEME::GENERATE-LOCAL-VARIABLE)
  188. (DEFUN GENERATE-PROGRAM-VARIABLE
  189.        (VAR ENV CONT)
  190.        ENV
  191.        (LET ((SUB (GET-INTEGRATION VAR)))
  192.          (DELIVER-VALUE-TO-CONT
  193.            (IF (CONSP SUB)
  194.                (CASE (CAR SUB)
  195.                      ((SCHEME::VAL) (CADR SUB))
  196.                      ((SCHEME::FUN) (CONS 'FUNCTION
  197.                                           (LIST (CADR SUB))))
  198.                      (OTHERWISE (NOTE-VARIABLE-REFERENCE! VAR)
  199.                                 (PROGRAM-VARIABLE-CL-SYMBOL VAR)))
  200.                (PROGN (NOTE-VARIABLE-REFERENCE! VAR)
  201.                       (PROGRAM-VARIABLE-CL-SYMBOL VAR)))
  202.            CONT)))
  203. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-PROGRAM-VARIABLE
  204.                               'SCHEME::GENERATE-PROGRAM-VARIABLE)
  205. (DEFUN GET-INTEGRATION
  206.        (VAR)
  207.        (DECLARE (SPECIAL INTEGRATIONS-TABLE))
  208.        (TABLE-REF INTEGRATIONS-TABLE VAR))
  209. (SCHI:SET-VALUE-FROM-FUNCTION 'GET-INTEGRATION
  210.                               'SCHEME::GET-INTEGRATION)
  211. (LOCALLY (DECLARE (SPECIAL *DECLARE-PROGRAM-VARIABLES-SPECIAL?*))
  212.          (SETQ *DECLARE-PROGRAM-VARIABLES-SPECIAL?* SCHI:TRUE))
  213. (SCHI:SET-FORWARDING-FUNCTION '*DECLARE-PROGRAM-VARIABLES-SPECIAL?*
  214.                               'SCHEME::*DECLARE-PROGRAM-VARIABLES-SPECIAL?*)
  215. (DEFUN NOTE-VARIABLE-REFERENCE!
  216.        (VAR)
  217.        (DECLARE
  218.          (SPECIAL @CL-VARIABLE-REFERENCES
  219.                   *DECLARE-PROGRAM-VARIABLES-SPECIAL?*))
  220.        (IF (AND
  221.              (NOT (SCHI:TRUEP (QUALIFIED-SYMBOL? (PROGRAM-VARIABLE-NAME VAR))))
  222.              (SCHI:TRUEP *DECLARE-PROGRAM-VARIABLES-SPECIAL?*))
  223.            (LET ((G (FLUID @CL-VARIABLE-REFERENCES)))
  224.              (IF (AND (NOT (EQ G
  225.                                'SCHEME::DONT-ACCUMULATE))
  226.                       (NOT (MEMBER VAR G :TEST #'EQ)))
  227.                  (SET-FLUID! @CL-VARIABLE-REFERENCES
  228.                              (CONS VAR G))))))
  229. (SCHI:SET-VALUE-FROM-FUNCTION 'NOTE-VARIABLE-REFERENCE!
  230.                               'SCHEME::NOTE-VARIABLE-REFERENCE!)
  231. (DEFUN GENERATE-CALL
  232.        (NODE ENV CONT)
  233.        (LET ((PROC (CALL-PROC NODE))
  234.              (ARGS (CALL-ARGS NODE)))
  235.          (CASE (NODE-TYPE PROC)
  236.                ((SCHEME::PROGRAM-VARIABLE)
  237.                  (IF (SCHI:TRUEP (MUTABLE-PROGRAM-VARIABLE? PROC))
  238.                      (GENERATE-GENERAL-CALL PROC ARGS ENV CONT)
  239.                      (GENERATE-CALL-TO-PROGRAM-VARIABLE PROC ARGS ENV CONT)))
  240.                ((SCHEME::LOCAL-VARIABLE)
  241.                  (IF (AND (CONSP (VARIABLE-SUBSTITUTION PROC))
  242.                           (EQ (CAR (VARIABLE-SUBSTITUTION PROC))
  243.                               'SCHEME::--GENERATE-CALL--))
  244.                      (FUNCALL (CADR (VARIABLE-SUBSTITUTION PROC))
  245.                               (GENERATE-LIST ARGS ENV)
  246.                               CONT)
  247.                      (GENERATE-GENERAL-CALL PROC ARGS ENV CONT)))
  248.                ((SCHEME::LAMBDA)
  249.                  (IF (AND (NOT (SCHI:TRUEP (N-ARY? PROC)))
  250.                           (= (LENGTH ARGS)
  251.                              (LENGTH (LAMBDA-VARS PROC))))
  252.                      (GENERATE-LET PROC ARGS ENV CONT)
  253.                      (GENERATE-GENERAL-CALL PROC ARGS ENV CONT)))
  254.                (OTHERWISE (GENERATE-GENERAL-CALL PROC ARGS ENV CONT)))))
  255. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-CALL
  256.                               'SCHEME::GENERATE-CALL)
  257. (DEFUN GENERATE-GENERAL-CALL
  258.        (PROC ARGS ENV CONT)
  259.        (DECLARE (SPECIAL CONT/VALUE))
  260.        (DELIVER-VALUE-TO-CONT
  261.          (FUNCALLIFY (GENERATE PROC ENV CONT/VALUE)
  262.                      (GENERATE-LIST ARGS ENV))
  263.          CONT))
  264. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-GENERAL-CALL
  265.                               'SCHEME::GENERATE-GENERAL-CALL)
  266. (DEFUN GENERATE-CALL-TO-PROGRAM-VARIABLE
  267.        (PVAR ARGS ENV CONT)
  268.        (DECLARE (SPECIAL CONT/TEST))
  269.        (LET ((SUB (GET-INTEGRATION PVAR)))
  270.          (IF (NOT (CONSP SUB))
  271.              (GENERATE-CALL-TO-UNKNOWN PVAR ARGS ENV CONT)
  272.              (CASE (CAR SUB)
  273.                    ((SCHEME::SUBST)
  274.                      (LET ((PARAMS (CADR SUB))
  275.                            (BODY (PROGNIFY (CDDR SUB))))
  276.                        (IF (= (LENGTH ARGS)
  277.                               (LENGTH PARAMS))
  278.                            (SUBSTITUTE-AND-PEEP
  279.                              (MAPCAR #'CONS
  280.                                      PARAMS
  281.                                      (GENERATE-LIST ARGS ENV))
  282.                              (DELIVER-VALUE-TO-CONT BODY CONT))
  283.                            (PROGN
  284.                              (NOTE "wrong number of arguments"
  285.                                    (MAKE-CALL PVAR ARGS))
  286.                              (GENERATE-CALL-TO-UNKNOWN PVAR ARGS ENV CONT)))))
  287.                    ((SCHEME::LAMBDA)
  288.                      (IF (= (LENGTH ARGS)
  289.                             (LENGTH (CADR SUB)))
  290.                          (CONS 'LET
  291.                                (CONS
  292.                                  (MAPCAR #'LIST
  293.                                          (CADR SUB)
  294.                                          (GENERATE-LIST ARGS ENV))
  295.                                  (DEPROGNIFY
  296.                                    (DELIVER-VALUE-TO-CONT
  297.                                      (PROGNIFY (CDDR SUB))
  298.                                      CONT))))
  299.                          (GENERATE-CALL-TO-UNKNOWN PVAR ARGS ENV CONT)))
  300.                    ((SCHEME::FUN)
  301.                      (DELIVER-VALUE-TO-CONT
  302.                        (CONS (CADR SUB)
  303.                              (GENERATE-LIST ARGS ENV))
  304.                        CONT))
  305.                    ((SCHEME::PRED)
  306.                      (DELIVER-TEST-TO-CONT
  307.                        (CONS (CADR SUB)
  308.                              (GENERATE-LIST ARGS ENV))
  309.                        CONT))
  310.                    ((SCHEME::VAL)
  311.                      (DELIVER-VALUE-TO-CONT
  312.                        (FUNCALLIFY (CADR SUB)
  313.                                    (GENERATE-LIST ARGS ENV))
  314.                        CONT))
  315.                    ((SCHEME::SPECIAL)
  316.                      (CASE (PROGRAM-VARIABLE-NAME PVAR)
  317.                            ((SCHEME::NOT)
  318.                              (IF (= (LENGTH ARGS) 1)
  319.                                  (DELIVER-TEST-TO-CONT
  320.                                    (CONS 'NOT
  321.                                          (LIST
  322.                                            (GENERATE (CAR ARGS)
  323.                                                      ENV
  324.                                                      CONT/TEST)))
  325.                                    CONT)
  326.                                  (GENERATE-CALL-TO-UNKNOWN PVAR ARGS ENV CONT)))
  327.                            ((SCHEME::AND-AUX)
  328.                              (GENERATE-AND (CAR ARGS)
  329.                                            (IF (SCHI:TRUEP
  330.                                                  (LAMBDA? (CADR ARGS)))
  331.                                                (LAMBDA-BODY (CADR ARGS))
  332.                                                (MAKE-CALL (CADR ARGS)
  333.                                                           'NIL))
  334.                                            ENV
  335.                                            CONT))
  336.                            ((SCHEME::OR-AUX)
  337.                              (GENERATE-OR (CAR ARGS)
  338.                                           (IF (SCHI:TRUEP
  339.                                                 (LAMBDA? (CADR ARGS)))
  340.                                               (LAMBDA-BODY (CADR ARGS))
  341.                                               (MAKE-CALL (CADR ARGS)
  342.                                                          'NIL))
  343.                                           ENV
  344.                                           CONT))
  345.                            ((SCHEME::CASE-AUX)
  346.                              (GENERATE-CASE (CAR ARGS)
  347.                                             (CADR ARGS)
  348.                                             (CADDR ARGS)
  349.                                             (CDDDR ARGS)
  350.                                             ENV
  351.                                             CONT))
  352.                            ((SCHEME::=>-AUX)
  353.                              (LET ((PROC-THUNK (CADR ARGS)))
  354.                                (LET ((PROC
  355.                                        (IF (SCHI:TRUEP (LAMBDA? PROC-THUNK))
  356.                                            (LAMBDA-BODY PROC-THUNK)
  357.                                            (MAKE-CALL PROC-THUNK 'NIL))))
  358.                                  (IF (AND (SCHI:TRUEP (LAMBDA? PROC))
  359.                                           (= (LENGTH (LAMBDA-VARS PROC))
  360.                                              1))
  361.                                      (GENERATE-=> (CAR ARGS)
  362.                                                   (CAR (LAMBDA-VARS PROC))
  363.                                                   (LAMBDA-BODY PROC)
  364.                                                   (CADDR ARGS)
  365.                                                   CONT)
  366.                                      (LET ((VAR
  367.                                              (MAKE-LOCAL-VARIABLE 'SCHEME::TEMP)))
  368.                                        (GENERATE-=> (CAR ARGS)
  369.                                                     VAR
  370.                                                     (MAKE-CALL PROC
  371.                                                                (LIST VAR))
  372.                                                     (CADDR ARGS)
  373.                                                     CONT))))))
  374.                            (OTHERWISE (.ERROR "losing built-in"
  375.                                               PVAR))))
  376.                    (OTHERWISE (.ERROR "losing CASE" SUB))))))
  377. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-CALL-TO-PROGRAM-VARIABLE
  378.                               'SCHEME::GENERATE-CALL-TO-PROGRAM-VARIABLE)
  379. (DEFUN GENERATE-AND
  380.        (.FIRST .SECOND ENV CONT)
  381.        (DECLARE (SPECIAL CONT/TEST))
  382.        (CASE (CONTINUATION-TYPE CONT)
  383.              ((SCHEME::CONT/TEST SCHEME::CONT/IGNORE)
  384.                (CONS 'AND
  385.                      (CONS (GENERATE .FIRST ENV CONT/TEST)
  386.                            (DEANDIFY (GENERATE .SECOND ENV CONT/TEST)))))
  387.              (OTHERWISE
  388.                (CONS 'IF
  389.                      (CONS (GENERATE .FIRST ENV CONT/TEST)
  390.                            (CONS (GENERATE .SECOND ENV CONT)
  391.                                  (LIST
  392.                                    (DELIVER-VALUE-TO-CONT 'SCHI:FALSE
  393.                                                           CONT))))))))
  394. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-AND
  395.                               'SCHEME::GENERATE-AND)
  396. (DEFUN GENERATE-OR
  397.        (.FIRST .SECOND ENV CONT)
  398.        (DECLARE (SPECIAL CONT/VALUE CONT/TEST))
  399.        (CASE (CONTINUATION-TYPE CONT)
  400.              ((SCHEME::CONT/TEST SCHEME::CONT/IGNORE)
  401.                (CONS 'OR
  402.                      (CONS (GENERATE .FIRST ENV CONT/TEST)
  403.                            (DEORIFY (GENERATE .SECOND ENV CONT)))))
  404.              (OTHERWISE
  405.                (LET ((FIRST-CODE (GENERATE .FIRST ENV CONT/VALUE)))
  406.                  (IF (SCHI:TRUEP (CAR-IS? FIRST-CODE 'SCHI:TRUE?))
  407.                      (CONS 'OR
  408.                            (CONS (CADR FIRST-CODE)
  409.                                  (DEORIFY (GENERATE .SECOND ENV CONT))))
  410.                      (LET ((VAR (MAKE-LOCAL-VARIABLE 'SCHEME::TEMP)))
  411.                        (LET ((NEW-NAME
  412.                                (CL-EXTERNALIZE-LOCAL 'SCHEME::TEMP
  413.                                                      ENV)))
  414.                          (LET ((NEW-ENV
  415.                                  (BIND-VARIABLES (LIST VAR)
  416.                                                  (LIST NEW-NAME)
  417.                                                  ENV)))
  418.                            (CONS 'LET
  419.                                  (CONS
  420.                                    (LIST (CONS NEW-NAME
  421.                                                (LIST FIRST-CODE)))
  422.                                    (LIST
  423.                                      (CONS 'IF
  424.                                            (CONS
  425.                                              (CONS 'SCHI:TRUEP
  426.                                                    (LIST NEW-NAME))
  427.                                              (CONS
  428.                                                (DELIVER-VALUE-TO-CONT NEW-NAME
  429.                                                                       CONT)
  430.                                                (LIST
  431.                                                  (GENERATE .SECOND
  432.                                                            NEW-ENV
  433.                                                            CONT))))))))))))))))
  434. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-OR
  435.                               'SCHEME::GENERATE-OR)
  436. (DEFUN GENERATE-CASE
  437.        (KEY KEY-LISTS ELSE-THUNK THUNKS ENV CONT)
  438.        (DECLARE (SPECIAL CONT/VALUE))
  439.        (CONS 'CASE
  440.              (CONS (GENERATE KEY ENV CONT/VALUE)
  441.                    (APPEND
  442.                      (MAPCAR
  443.                        #'(LAMBDA (KEY-LIST THUNK)
  444.                           (CONS KEY-LIST
  445.                            (DEPROGNIFY
  446.                             (GENERATE
  447.                              (IF (SCHI:TRUEP (LAMBDA? THUNK))
  448.                               (LAMBDA-BODY THUNK) (MAKE-CALL THUNK 'NIL))
  449.                              ENV CONT))))
  450.                        (IF (SCHI:TRUEP (CONSTANT? KEY-LISTS))
  451.                            (CONSTANT-VALUE KEY-LISTS)
  452.                            (.ERROR "case: invalid key-lists"
  453.                                    KEY-LISTS))
  454.                        THUNKS)
  455.                      (LIST
  456.                        (CONS 'OTHERWISE
  457.                              (DEPROGNIFY
  458.                                (GENERATE
  459.                                  (IF (SCHI:TRUEP (LAMBDA? ELSE-THUNK))
  460.                                      (LAMBDA-BODY ELSE-THUNK)
  461.                                      (MAKE-CALL ELSE-THUNK 'NIL))
  462.                                  ENV
  463.                                  CONT))))))))
  464. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-CASE
  465.                               'SCHEME::GENERATE-CASE)
  466. (DEFUN GENERATE-=>
  467.        (TEST VAR THEN ELSE-THUNK CONT)
  468.        (DECLARE (SPECIAL CONT/TEST ENV))
  469.        (LET ((NEW-NAME (CL-EXTERNALIZE-LOCAL (LOCAL-VARIABLE-NAME VAR)
  470.                                              ENV)))
  471.          (LET ((NEW-ENV (BIND-VARIABLES (LIST VAR)
  472.                                         (LIST NEW-NAME)
  473.                                         ENV)))
  474.            (CONS 'LET
  475.                  (CONS
  476.                    (LIST
  477.                      (CONS NEW-NAME
  478.                            (LIST (GENERATE TEST ENV CONT/TEST))))
  479.                    (LIST
  480.                      (CONS 'IF
  481.                            (CONS NEW-NAME
  482.                                  (CONS (GENERATE THEN NEW-ENV CONT)
  483.                                        (LIST
  484.                                          (GENERATE
  485.                                            (IF (SCHI:TRUEP
  486.                                                  (LAMBDA? ELSE-THUNK))
  487.                                                (LAMBDA-BODY ELSE-THUNK)
  488.                                                (MAKE-CALL ELSE-THUNK 'NIL))
  489.                                            NEW-ENV
  490.                                            CONT)))))))))))
  491. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-=>
  492.                               'SCHEME::GENERATE-=>)
  493. (DEFUN GENERATE-CALL-TO-UNKNOWN
  494.        (PVAR ARGS ENV CONT)
  495.        (LET ((CL-SYM (PROGRAM-VARIABLE-CL-SYMBOL PVAR))
  496.              (ARGS-CODE (GENERATE-LIST ARGS ENV)))
  497.          (DELIVER-VALUE-TO-CONT
  498.            (IF (AND (NOT (SCHI:TRUEP (QUALIFIED-SYMBOL? CL-SYM)))
  499.                     (NOT (EQ (MACRO-FUNCTION CL-SYM)
  500.                              'NIL)))
  501.                (CONS 'FUNCALL
  502.                      (CONS CL-SYM ARGS-CODE))
  503.                (CONS CL-SYM ARGS-CODE))
  504.            CONT)))
  505. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-CALL-TO-UNKNOWN
  506.                               'SCHEME::GENERATE-CALL-TO-UNKNOWN)
  507. (DEFUN GENERATE-LAMBDA
  508.        (NODE ENV CONT)
  509.        (DECLARE (SPECIAL CONT/VALUE
  510.                          @LAMBDA-ENCOUNTERED?))
  511.        (SET-FLUID! @LAMBDA-ENCOUNTERED? SCHI:TRUE)
  512.        (DELIVER-VALUE-TO-CONT
  513.          (CONS 'FUNCTION
  514.                (LIST
  515.                  (CONS 'LAMBDA
  516.                        (GENERATE-LAMBDA-AUX NODE ENV CONT/VALUE))))
  517.          CONT))
  518. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LAMBDA
  519.                               'SCHEME::GENERATE-LAMBDA)
  520. (DEFUN GENERATE-LAMBDA-AUX
  521.        (NODE ENV CONT)
  522.        (LET ((BVL (LAMBDA-VARS NODE)))
  523.          (LET ((VARS (PROPER-LISTIFY BVL)))
  524.            (LET ((NEW-NAMES (CL-EXTERNALIZE-LOCALS VARS ENV)))
  525.              (LET ((NEW-ENV (BIND-VARIABLES VARS NEW-NAMES ENV)))
  526.                (LET ((BODY-CODE
  527.                        (GENERATE-BODY (LAMBDA-BODY NODE)
  528.                                       NEW-ENV
  529.                                       CONT)))
  530.                  (IF (SCHI:TRUEP (N-ARY? NODE))
  531.                      (LET ((BVL@0 (INSERT-&REST NEW-NAMES)))
  532.                        (LET ((REST-VAR (CAR (LAST-PAIR BVL@0))))
  533.                          (CONS BVL@0
  534.                                (APPEND
  535.                                  (EMIT-SHARP-PLUS ':LISPM
  536.                                                   (CONS 'SETQ
  537.                                                         (CONS REST-VAR
  538.                                                               (LIST
  539.                                                                 (CONS
  540.                                                                   'COPY-LIST
  541.                                                                   (LIST
  542.                                                                     REST-VAR))))))
  543.                                  BODY-CODE))))
  544.                      (CONS NEW-NAMES BODY-CODE))))))))
  545. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LAMBDA-AUX
  546.                               'SCHEME::GENERATE-LAMBDA-AUX)
  547. (DEFUN GENERATE-LET
  548.        (PROC ARGS ENV CONT)
  549.        (DECLARE (SPECIAL CONT/VALUE))
  550.        (LET ((VARS (LAMBDA-VARS PROC)))
  551.          (IF (SCHI:TRUEP (FUNCTION-BINDABLE? VARS ARGS))
  552.              (LET ((NEW-NAMES (CL-EXTERNALIZE-LOCALS VARS ENV)))
  553.                (LET ((NEW-ENV (BIND-FUNCTIONS VARS NEW-NAMES ENV)))
  554.                  (CONS 'FLET
  555.                        (CONS
  556.                          (MAPCAR
  557.                            #'(LAMBDA (NEW-NAME PROC@0)
  558.                               (CONS NEW-NAME
  559.                                (GENERATE-LAMBDA-AUX PROC@0 ENV CONT/VALUE)))
  560.                            NEW-NAMES
  561.                            ARGS)
  562.                          (GENERATE-BODY (LAMBDA-BODY PROC)
  563.                                         NEW-ENV
  564.                                         CONT)))))
  565.              (LET ((BVL+BODY (GENERATE-LAMBDA-AUX PROC ENV CONT)))
  566.                (CONS 'LET
  567.                      (CONS
  568.                        (MAPCAR #'LIST
  569.                                (CAR BVL+BODY)
  570.                                (GENERATE-LIST ARGS ENV))
  571.                        (CDR BVL+BODY)))))))
  572. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LET
  573.                               'SCHEME::GENERATE-LET)
  574. (DEFUN GENERATE-IF
  575.        (NODE ENV CONT)
  576.        (DECLARE (SPECIAL CONT/TEST
  577.                          @TRANSLATING-TO-FILE?))
  578.        (LET ((TEST (GENERATE (IF-TEST NODE) ENV CONT/TEST))
  579.              (CON (GENERATE (IF-CON NODE) ENV CONT))
  580.              (ALT (GENERATE (IF-ALT NODE) ENV CONT)))
  581.          (IF (AND (EQ ALT 'SCHI:UNSPECIFIED)
  582.                   (OR (EQ (CONTINUATION-TYPE CONT)
  583.                           'SCHEME::CONT/IGNORE)
  584.                       (SCHI:TRUEP (FLUID @TRANSLATING-TO-FILE?))))
  585.              (CONS 'IF
  586.                    (CONS TEST (LIST CON)))
  587.              (CONS 'IF
  588.                    (CONS TEST
  589.                          (CONS CON (LIST ALT)))))))
  590. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-IF
  591.                               'SCHEME::GENERATE-IF)
  592. (DEFUN GENERATE-BEGIN
  593.        (NODE ENV CONT)
  594.        (DECLARE (SPECIAL CONT/IGNORE))
  595.        (PROGNIFY
  596.          (APPEND (DEPROGNIFY (GENERATE (BEGIN-FIRST NODE)
  597.                                        ENV
  598.                                        CONT/IGNORE))
  599.                  (DEPROGNIFY (GENERATE (BEGIN-SECOND NODE)
  600.                                        ENV
  601.                                        CONT)))))
  602. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-BEGIN
  603.                               'SCHEME::GENERATE-BEGIN)
  604. (DEFUN GENERATE-SET!
  605.        (NODE ENV CONT)
  606.        (DECLARE (SPECIAL CONT/VALUE))
  607.        (LET ((VAR (SET!-LHS NODE))
  608.              (RHS-CODE (GENERATE (SET!-RHS NODE)
  609.                                  ENV
  610.                                  CONT/VALUE)))
  611.          (IF (SCHI:TRUEP (PROGRAM-VARIABLE? VAR))
  612.              (PROGN
  613.                (IF (SCHI:TRUEP (GET-INTEGRATION VAR))
  614.                    (NOTE "SET! of an integrated variable"
  615.                          NODE))
  616.                (LET ((CL-SYM (PROGRAM-VARIABLE-CL-SYMBOL VAR)))
  617.                  (NOTE-VARIABLE-REFERENCE! VAR)
  618.                  (DELIVER-VALUE-TO-CONT
  619.                    (EMIT-PROGRAM-VARIABLE-SET! VAR CL-SYM RHS-CODE)
  620.                    CONT)))
  621.              (LET ((THE-SETQ
  622.                      (CONS 'SETQ
  623.                            (CONS (VARIABLE-SUBSTITUTION VAR)
  624.                                  (LIST RHS-CODE)))))
  625.                (IF (EQ (CONTINUATION-TYPE CONT)
  626.                        'SCHEME::CONT/IGNORE)
  627.                    THE-SETQ
  628.                    (CONS 'PROGN
  629.                          (CONS THE-SETQ
  630.                                (LIST
  631.                                  (DELIVER-VALUE-TO-CONT 'SCHI:UNSPECIFIED
  632.                                                         CONT)))))))))
  633. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-SET!
  634.                               'SCHEME::GENERATE-SET!)
  635. (DEFUN GENERATE-LETREC
  636.        (NODE ENV CONT)
  637.        (CASE (GET-LETREC-STRATEGY NODE)
  638.              ((SCHEME::GENERAL) (GENERATE-GENERAL-LETREC NODE ENV CONT))
  639.              ((SCHEME::LABELS) (GENERATE-LABELS-LETREC NODE ENV CONT))
  640.              ((SCHEME::PROG) (GENERATE-PROG-LETREC NODE ENV CONT))
  641.              (OTHERWISE
  642.                (.ERROR "unknown strategy"
  643.                        (GET-LETREC-STRATEGY NODE)))))
  644. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LETREC
  645.                               'SCHEME::GENERATE-LETREC)
  646. (DEFUN GENERATE-GENERAL-LETREC
  647.        (NODE ENV CONT)
  648.        (DECLARE (SPECIAL CONT/VALUE))
  649.        (LET ((VARS (LETREC-VARS NODE)))
  650.          (LET ((VALS (LETREC-VALS NODE)))
  651.            (LET ((NEW-NAMES (CL-EXTERNALIZE-LOCALS VARS ENV)))
  652.              (LET ((NEW-ENV (BIND-VARIABLES VARS NEW-NAMES ENV)))
  653.                (CONS 'LET
  654.                      (CONS
  655.                        (MAPCAR
  656.                          #'(LAMBDA (NEW-NAME)
  657.                             (CONS NEW-NAME '(SCHI:UNASSIGNED)))
  658.                          NEW-NAMES)
  659.                        (APPEND
  660.                          (MAPCAR
  661.                            #'(LAMBDA (VAR VAL)
  662.                               (CONS 'SETQ
  663.                                (CONS VAR
  664.                                 (LIST (GENERATE VAL NEW-ENV CONT/VALUE)))))
  665.                            NEW-NAMES
  666.                            VALS)
  667.                          (DEPROGNIFY
  668.                            (GENERATE (LETREC-BODY NODE)
  669.                                      NEW-ENV
  670.                                      CONT))))))))))
  671. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-GENERAL-LETREC
  672.                               'SCHEME::GENERATE-GENERAL-LETREC)
  673. (DEFUN GENERATE-LABELS-LETREC
  674.        (NODE ENV CONT)
  675.        (DECLARE (SPECIAL CONT/VALUE))
  676.        (LET ((VARS (LETREC-VARS NODE)))
  677.          (LET ((VALS (LETREC-VALS NODE)))
  678.            (LET ((NEW-NAMES (CL-EXTERNALIZE-LOCALS VARS ENV)))
  679.              (LET ((NEW-ENV (BIND-FUNCTIONS VARS NEW-NAMES ENV)))
  680.                (CONS 'LABELS
  681.                      (CONS
  682.                        (MAPCAR
  683.                          #'(LAMBDA (NEW-NAME PROC)
  684.                             (CONS NEW-NAME
  685.                              (GENERATE-LAMBDA-AUX PROC NEW-ENV CONT/VALUE)))
  686.                          NEW-NAMES
  687.                          VALS)
  688.                        (GENERATE-BODY (LETREC-BODY NODE)
  689.                                       NEW-ENV
  690.                                       CONT))))))))
  691. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-LABELS-LETREC
  692.                               'SCHEME::GENERATE-LABELS-LETREC)
  693. (DEFUN GENERATE-PROG-LETREC
  694.        (NODE ENV CONT)
  695.        (DECLARE (SPECIAL CONT/RETURN
  696.                          SET-LETREC-SUBSTITUTION!))
  697.        (LET ((VARS (LETREC-VARS NODE)))
  698.          (LET ((PROCS (LETREC-VALS NODE)))
  699.            (LET ((NEW-NAMES (CL-EXTERNALIZE-LOCALS VARS ENV)))
  700.              (LET ((NEW-ENV (BIND-VARIABLES VARS NEW-NAMES ENV)))
  701.                (LET ((TEMP-LISTS
  702.                        (MAPCAR
  703.                          #'(LAMBDA (PROC)
  704.                             (MAPCAR
  705.                              #'(LAMBDA (VAR)
  706.                                 (IF (SCHI:TRUEP (VARIABLE-CLOSED-OVER? VAR))
  707.                                  (MAKE-NAME-FROM-UID (LOCAL-VARIABLE-NAME VAR)
  708.                                   (GENERATE-UID))
  709.                                  SCHI:FALSE))
  710.                              (LAMBDA-VARS PROC)))
  711.                          PROCS)))
  712.                  (LET ((PROC-NEW-NAMESES
  713.                          (MAPCAR
  714.                            #'(LAMBDA (PROC)
  715.                               (CL-EXTERNALIZE-LOCALS (LAMBDA-VARS PROC) NEW-ENV))
  716.                            PROCS)))
  717.                    (LET ((PROC-ENVS
  718.                            (MAPCAR
  719.                              #'(LAMBDA (PROC NEW-NAMES@2)
  720.                                 (BIND-VARIABLES (LAMBDA-VARS PROC) NEW-NAMES@2
  721.                                  NEW-ENV))
  722.                              PROCS
  723.                              PROC-NEW-NAMESES)))
  724.                      (MAPC SET-LETREC-SUBSTITUTION!
  725.                            VARS
  726.                            NEW-NAMES
  727.                            PROC-NEW-NAMESES
  728.                            TEMP-LISTS)
  729.                      (DELIVER-VALUE-TO-CONT
  730.                        (CONS 'PROG
  731.                              (CONS
  732.                                (APPLY #'APPEND
  733.                                       (MAPCAR
  734.                                         #'(LAMBDA (TEMP-LIST NEW-NAMES@0)
  735.                                            (MAPCAR
  736.                                             #'(LAMBDA (TEMP NEW-NAME)
  737.                                                (LET ((TEMP@1 TEMP))
  738.                                                 (IF (SCHI:TRUEP TEMP@1) TEMP@1
  739.                                                  NEW-NAME)))
  740.                                             TEMP-LIST NEW-NAMES@0))
  741.                                         TEMP-LISTS
  742.                                         PROC-NEW-NAMESES))
  743.                                (APPEND
  744.                                  (GENERATE-BODY (LETREC-BODY NODE)
  745.                                                 NEW-ENV
  746.                                                 CONT/RETURN)
  747.                                  (APPLY #'APPEND
  748.                                         (MAPCAR
  749.                                           #'(LAMBDA
  750.                                              (NEW-NAME PROC TEMP-LIST
  751.                                               PROC-NEW-NAMES PROC-ENV)
  752.                                              (CONS NEW-NAME
  753.                                               (LIST
  754.                                                (LETIFY
  755.                                                 (FILTER #'CADR
  756.                                                  (MAPCAR #'LIST PROC-NEW-NAMES
  757.                                                   TEMP-LIST))
  758.                                                 (GENERATE (LAMBDA-BODY PROC)
  759.                                                  PROC-ENV CONT/RETURN)))))
  760.                                           NEW-NAMES
  761.                                           PROCS
  762.                                           TEMP-LISTS
  763.                                           PROC-NEW-NAMESES
  764.                                           PROC-ENVS)))))
  765.                        CONT)))))))))
  766. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATE-PROG-LETREC
  767.                               'SCHEME::GENERATE-PROG-LETREC)
  768. (DEFUN SET-LETREC-SUBSTITUTION!
  769.        (VAR NEW-NAME PROC-NEW-NAMES TEMP-LIST)
  770.        (SET-SUBSTITUTION! VAR
  771.                           (LIST 'SCHEME::--GENERATE-CALL--
  772.                                 #'(LAMBDA (ARGS CONT)
  773.                                    (IF
  774.                                     (NOT
  775.                                      (EQ (CONTINUATION-TYPE CONT)
  776.                                       'SCHEME::CONT/RETURN))
  777.                                     (NOTE "screwed-up LETREC" CONT))
  778.                                    (IF (NULL ARGS) (CONS 'GO (LIST NEW-NAME))
  779.                                     (CONS 'PROGN
  780.                                      (CONS
  781.                                       (CONS
  782.                                        (IF (NULL (CDR ARGS)) 'SETQ 'PSETQ)
  783.                                        (APPLY #'APPEND
  784.                                         (MAPCAR
  785.                                          #'(LAMBDA (NEW-NAME@0 TEMP ACTUAL)
  786.                                             (CONS
  787.                                              (LET ((TEMP@1 TEMP))
  788.                                               (IF (SCHI:TRUEP TEMP@1) TEMP@1
  789.                                                NEW-NAME@0))
  790.                                              (LIST ACTUAL)))
  791.                                          PROC-NEW-NAMES TEMP-LIST ARGS)))
  792.                                       (LIST (CONS 'GO (LIST NEW-NAME))))))))))
  793. (SCHI:SET-VALUE-FROM-FUNCTION 'SET-LETREC-SUBSTITUTION!
  794.                               'SCHEME::SET-LETREC-SUBSTITUTION!)
  795.